(in-package :cl-fast-ecs)


(declaim
 (inline entity-valid-p)
 (ftype (function (entity) boolean) entity-valid-p))
(defun entity-valid-p (entity)
  "Return `T` if entity is valid.

Complexity: *O(1)*."
  (not (minusp entity)))

(defhook :entity-storage-grown
  :documentation
  "Called after the entity storate capacity is increased due to new entity being
added. Argument for the call is the new storage capacity.

Note: this is a good place to call for a full GC cycle to collect old storage
arrays.

See `HOOK-UP`.")

(declaim (ftype (function () entity) make-entity))
(defun make-entity ()
  "Creates and returns a new componentless entity.

Note that when no entities were deleted, `MAKE-ENTITY` returns new ones in
strictly ascending order, i.e. the entities would be processed by systems in
the order they've been created. When there are deleted entities, they'd be
reclaimed by `MAKE-ENTITY`.

Complexity: amortized *O(1)*.

See also `DELETE-ENTITY`."
  (with-storage ()
    (if (zerop (storage-deleted-entities-count storage))
        (let ((entity (storage-entities-count storage)))
          (incf (storage-entities-count storage))
          (when (> (storage-entities-count storage)
                   *storage-entities-allocated*)
            (let ((new-size (new-capacity *storage-entities-allocated*)))
              (setf *storage-entities-allocated* new-size)
              (loop :for component-storage :of-type component-soa
                    :across (storage-component-storages storage)
                    :do (adjust-simple-arrayf
                         (component-soa-exists component-storage)
                         new-size :element-type 'bit :initial-element 0))
              (run-hook *entity-storage-grown-hook* new-size)))
          entity)
        (aref (storage-deleted-entities storage)
              (decf (storage-deleted-entities-count storage))))))

(defmacro with-checked-entity (entity &body body)
  (declare (ignorable entity))
  #-ecs-release `(let ((,entity ,entity))
                   (declare (type entity ,entity))
                   (assert (< ,entity (storage-entities-count *storage*))
                           (,entity))
                   ,@body)
  #+ecs-release `(progn ,@body))

(defhook :entity-deleting
  :documentation
  "Called before deleting an entity. An argument for the call is the entity
about to be deleted.

Note: this is a perfect place to delete entity's children when implementing
parent/child relationships.

See also `DELETE-ENTITY`, `HOOK-UP`.")

(declaim (ftype (function (entity)) delete-entity))
(defun delete-entity (entity)
  "Deletes given `ENTITY` and all of its components in the order they've been
defined with `DEFCOMPONENT`.

Complexity: amortized *O(m + log p)*, where *m* is the number of defined
components, and *p* is the number of deleted & unreclaimed entities so far."
  (with-storage ()
    (with-checked-entity entity
      (run-hook *entity-deleting-hook* entity)
      (loop :for component-storage :of-type component-soa
            :across (storage-component-storages storage)
            :for i :of-type array-index :from 0
            :unless (zerop (sbit (component-soa-exists component-storage) entity))
            :do (delete-component i entity))
      (let ((deleted-entities (storage-deleted-entities storage))
            (count (storage-deleted-entities-count storage)))
        (when (= (length deleted-entities) count)
          (adjust-simple-arrayf deleted-entities
                                (new-capacity count)
                                :element-type 'entity :initial-element -1)
          (setf (storage-deleted-entities storage) deleted-entities))
        (let ((pivot (binary-search deleted-entities entity #'< :end count)))
          (replace deleted-entities deleted-entities
                   :start1 (1+ pivot) :start2 pivot)
          (setf (aref deleted-entities pivot) entity
                (storage-deleted-entities-count storage) (1+ count))))
      nil)))

(declaim (ftype (function (entity &key (:destination entity) (:except list)))
                copy-entity))
(defun copy-entity (source &key (destination (make-entity)) except)
  "Copies all components present in `SOURCE` entity to `DESTINATION`
entity (freshly created entity by default), overriding any existing data.
Skips components denoted by keywords in optional `EXCEPT` list.

See also `REPLACE-COMPONENT`."
  (loop :for name :of-type keyword :in except
        :when (null (find name *component-registry* :test #'eq))
        :do (error "Unknown component: ~a" name))
  (loop :with component-storages := (storage-component-storages
                                     (the storage *storage*))
        :with cnt :of-type fixnum := (1- *component-registry-length*)
        :for i :of-type array-index :from 0
        :for (component . nil) :on *component-registry* :by #'cddr
        :when (and (null (find component except :test #'eq))
                   (not (zerop (sbit
                                (component-soa-exists
                                 (svref component-storages (- cnt i)))
                                source))))
        :do (funcall #'replace-component (- cnt i) destination source)
        :finally (return destination)))

(declaim (ftype (function (list) (values entity &optional)) make-object))
(defun make-object (spec)
  "Creates and returns a new object (that is, an entity with a set of
components) following specification `SPEC` structured as follows:

```
'((:component-name1 :component-slot1 \"value1\" :component-slot2 2.0)
  (:component-name2 :component-slot 42)
  ;; ...
  )
```

Complexity: *O(m)*, where *m* is the number of components in the given `SPEC`.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives.

For a technical reasons, the count of component specifiers in `SPEC` should
not exceed 4000 (which is more than enough for any practical usage).

See also `MAKE-ENTITY`, `DELETE-ENTITY`."
  (let* ((length (length spec))
         (indices (make-array (the (integer 0 4000) length)
                              :element-type 'array-index)))
    (declare #-ccl (type (simple-array array-index) indices)
             (dynamic-extent indices))
    (loop :for (name . nil) :in spec
          :for i :of-type array-index :from 0
          :for idx :of-type (or null array-index) :=
             (position name *component-registry* :test #'eq)
          :do (if (null idx)
                  (error "Unknown component: ~a" name)
                  (setf (aref indices i) (ash idx -1))))
    (loop :with entity :of-type entity := (make-entity)
          :with cnt :of-type fixnum := (1- *component-registry-length*)
          :for i :of-type array-index :from 0
          :for (nil . parameters) :in spec
          :for idx :of-type array-index := (aref indices i)
          :do (apply #'make-component (- cnt idx) entity parameters)
          :finally (return entity))))

(defun %quasiquotep (form)
  (declare (ignorable form))
  #-sbcl nil
  #+sbcl (eq (first form) 'sb-int:quasiquote))

(define-compiler-macro make-object (&whole form spec)
  (cond ((not (listp spec)) form)
        ((constantp (second form))
         `(let ((entity (make-entity)))
            ,@(mapcar (lambda (c) `(,(symbolicate :make- (first c))
                               entity ,@(rest c)))
                      (eval spec))
            entity))
        #+sbcl
        ((%quasiquotep (second form))
         `(let ((entity (make-entity)))
            ,@(mapcar (lambda (c) `(,(symbolicate :make- (first c))
                               entity ,@(mapcar
                                         (lambda (e)
                                           (if (sb-impl::comma-p e)
                                               (sb-impl::comma-expr e)
                                               e))
                                         (rest c))))
                      (second spec))
            entity))
        (t
         form)))

(defmacro defentity (name spec &optional documentation)
  "Defines a global variable named `NAME` holding an entity that is initialized
automatically along with the data storage according to specification `SPEC`
structured the same way as for `MAKE-OBJECT`. Supports optional docstring via
`DOCUMENTATION` argument.

NOTE: the variable is created by means of
[global-vars](https://github.com/lmj/global-vars) library and hence cannot be
dynamically bound.

See also: `MAKE-STORAGE`."
  (let ((ctor (gensym (format nil "~a-CTOR" name))))
    `(progn
       (when-let (hook (get ',name 'init-global-entity))
         (unhook *storage-initialized-hook* hook))
       (define-global-parameter ,name -1 ,documentation)
       (flet ((,ctor (&optional storage)
                (declare (ignore storage))
                (setf ,name (make-object ,spec))))
         (setf (get ',name 'init-global-entity) #',ctor)
         (hook-up *storage-initialized-hook* #',ctor)
         (when *storage*
           (,ctor *storage*))))))

(defmacro define-entity (name spec &optional documentation)
  "An alias for `DEFENTITY`."
  `(defentity ,name ,spec ,documentation))

(defun spec-adjoin (spec item)
  "Adjoins single non-empty component specification `ITEM` to object
specification `SPEC` as if by `ADJOIN`, i.e. if spec already has given
component spec, returns it untouched, otherwise returns the new spec with
given component spec added.

See also `MAKE-OBJECT`."
  (if item
      (adjoin item spec :test #'eq :key #'first)
      spec))

(defvar *skip-printing-components* nil
  "A list of keywords denoting components that should be skipped while printing
entities.")

(defun print-entity (entity &optional (stream *standard-output*))
  "Prints given `ENTITY` to the `STREAM` in a way that is compatible with
`MAKE-OBJECT`. To be used in debugging scenarios.

See also `*SKIP-PRINTING-COMPONENTS*`."
  (prin1
   (loop :with devnull := (make-broadcast-stream)
         :with component-storages := (storage-component-storages
                                      (the storage *storage*))
         :with cnt :of-type fixnum := (1- *component-registry-length*)
         :with skip-list
           := (mapcar
               (lambda (name)
                 (let ((idx (position name *component-registry* :test #'eq)))
                   (declare (type (or null array-index) idx))
                   (if (null idx)
                       (error
                        "Unknown component in *SKIP-PRINTING-COMPONENTS*: ~a"
                        name)
                       (- cnt (ash idx -1)))))
               *skip-printing-components*)
         :with indices :of-type list
           := (sort (nset-difference (iota *component-registry-length*)
                                     skip-list
                                     :test (lambda (x y)
                                             (declare (type array-index x y))
                                             (= x y)))
                    (lambda (x y) (declare (type array-index x y)) (< x y)))
         :for i :of-type array-index :in indices
         :for exists := (component-soa-exists (svref component-storages i))
         :unless (zerop (sbit exists entity))
         :collect (print-component i entity devnull))
   stream))

(define-modify-macro unionf (set &rest keywords) nunion)

(defun print-entities/picture (entities filename
                               &key (name-getter #'identity)
                                 (value-printer #'identity)
                                 (bg-color :white) (format :png) keep-source)
  "Prints given list of `ENTITIES` to the picture identified by `FILENAME` and
`FORMAT` (defaulting to PNG), and keeps Graphviz source file if `KEEP-SOURCE`
is `T`. Image's background color could be specified by the string designator
`BG-COLOR`.

Entity names would be printed according to `NAME-GETTER`, a function of one
argument that takes an entity and returns any value. Component slot values
would be printed according to `VALUE-PRINTER`, a function of one argument that
takes a value and returns its representation.

To be used in debugging and demo scenarios.

See also `*SKIP-PRINTING-COMPONENTS*`."
  (uiop:with-temporary-file (:pathname dot-filename
                             :type "dot"
                             :keep keep-source)
    (with-open-file (file dot-filename
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
      (let* ((data (loop :with devnull := (make-broadcast-stream)
                         :for entity :of-type entity :in entities
                         :for printed-entity :of-type list
                           := (print-entity entity devnull)
                         :nconcing
                         (list (funcall name-getter entity) printed-entity)))
             (components (sort
                          (loop :with result := nil
                                :for (nil value) :on data :by #'cddr
                                :do (unionf result (mapcar #'car value)
                                            :test #'eq)
                                :finally (return result))
                          (lambda (a b)
                            (> (position a *component-registry* :test #'eq)
                               (position b *component-registry* :test #'eq))))))
        (format file "graph entities {~%bgcolor=\"~(~a~)\"~%node [shape=oval,"
                bg-color)
        (format file "fontname=\"SourceSans3\",style=filled,fillcolor=gray]~%")
        (format file "rank=same {~{\"~a\"~^ -- ~}}~%" components)
        (format file "node [fontname=\"SourceSans3\",shape=rect,style=\"\"]~%")
        (loop :for (entity component-data) :on data :by #'cddr
              :do (format file "\"~a\" [label=\"~:*~a\",shape=plaintext]~%"
                          entity)
                  (loop :for component :in component-data
                        :do (format file "\"~a-~a\" [label=\""
                                    (first component) entity)
                            (loop :for (k v) :on (rest component) :by #'cddr
                                  :do (format file "~a = ~a\\l"
                                              k (funcall value-printer v))
                                  :finally (format file "\"]~%")))
                  (format file "rank=same {\"~a\"" entity)
                  (loop :for component :in component-data
                        :do (format file " -- \"~a-~a\"" (car component) entity)
                        :finally (format file "}~%")))
        (format file "edge [style=invis]~%")
        (format file "~{\"~a\"~*~^ -- ~}~%" data)
        (format file "edge [weight=1000,style=dashed,color=dimgrey]~%")
        (loop :for component :in components
              :do (format file "\"~a\"" component)
                  (loop :for (entity component-data) :on data :by #'cddr
                        :when (find component component-data
                                    :test #'eq :key #'car)
                          :do (format file " -- \"~a-~a\"" component entity)
                        :finally (format file "~%")))
        (format file "}")))
    (uiop:run-program
     (format nil "dot -T~(~a~) ~a > ~a" format dot-filename filename))
    (when keep-source
      dot-filename)))
